home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / XLisp / xldmem.c < prev    next >
C/C++ Source or Header  |  1990-10-04  |  17KB  |  795 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include <string.h>
  7. #include <stdlib.h>
  8. #include "xlisp.h"
  9. #include "osdef.h"
  10. #ifdef ANSI
  11. #include "xlproto.h"
  12. #include "Stproto.h"
  13. #include "osproto.h"
  14. #else
  15. #include "xlfun.h"
  16. #include "Stfun.h"
  17. #include "osfun.h"
  18. #endif ANSI
  19. #include "xlvar.h"
  20.  
  21. /* forward declarations */
  22. #ifdef ANSI
  23. unsigned char *stralloc(int);
  24. void findmem(void),mark(LVAL),sweep(void),stats(void);
  25. int addseg(void);
  26. char *IViewNewAData(int,int,long *,int);
  27. LVAL newnode(int);
  28. #else
  29. unsigned char *stralloc();
  30. void findmem(),mark(),sweep(),stats();
  31. int addseg();
  32. char *IViewNewAData();
  33. LVAL newnode();
  34. #endif
  35.  
  36. /* node flags */
  37. #define MARK    1
  38. #define LEFT    2
  39.  
  40. /* macro to compute the size of a segment */
  41. #define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
  42.  
  43. /* variables local to xldmem.c and xlimage.c */
  44. SEGMENT *segs,*lastseg,*fixseg,*charseg;
  45. int anodes,nsegs,gccalls;
  46. long nnodes,nfree,total;
  47. LVAL fnodes;
  48.  
  49. /* cons - construct a new cons node */
  50. LVAL cons(x,y)
  51.   LVAL x,y;
  52. {
  53.     LVAL nnode;
  54.  
  55.     /* get a free node */
  56.     if ((nnode = fnodes) == NIL) {
  57.     xlstkcheck(2);
  58.     xlprotect(x);
  59.     xlprotect(y);
  60.     findmem();
  61.     if ((nnode = fnodes) == NIL)
  62.         xlabort("insufficient node space");
  63.     xlpop();
  64.     xlpop();
  65.     }
  66.  
  67.     /* unlink the node from the free list */
  68.     fnodes = cdr(nnode);
  69.     --nfree;
  70.  
  71.     /* initialize the new node */
  72.     nnode->n_type = CONS;
  73.     rplaca(nnode,x);
  74.     rplacd(nnode,y);
  75.  
  76.     /* return the new node */
  77.     return (nnode);
  78. }
  79.  
  80. /* cvstring - convert a string to a string node */
  81. LVAL cvstring(str)
  82.   char *str;
  83. {
  84.     LVAL val;
  85.     xlsave1(val);
  86.     val = newnode(STRING);
  87.     val->n_strlen = strlen(str) + 1;
  88.     val->n_string = stralloc(getslength(val));
  89.     strcpy(getstring(val),str);
  90.     xlpop();
  91.     return (val);
  92. }
  93.  
  94. /* newstring - allocate and initialize a new string */
  95. LVAL newstring(size)
  96.   int size;
  97. {
  98.     LVAL val;
  99.     xlsave1(val);
  100.     val = newnode(STRING);
  101.     val->n_strlen = size;
  102.     val->n_string = stralloc(getslength(val));
  103.     strcpy(getstring(val),"");
  104.     xlpop();
  105.     return (val);
  106. }
  107.  
  108. /* cvsymbol - convert a string to a symbol */
  109. LVAL cvsymbol(pname)
  110.   char *pname;
  111. {
  112.     LVAL val;
  113.     xlsave1(val);
  114.     val = newvector(SYMSIZE);
  115.     val->n_type = SYMBOL;
  116.     setvalue(val,s_unbound);
  117.     setfunction(val,s_unbound);
  118.     setpname(val,cvstring(pname));
  119.     setconstant(val, FALSE); /* L. Tierney */
  120.     xlpop();
  121.     return (val);
  122. }
  123.  
  124. /* cvsubr - convert a function to a subr or fsubr */
  125. LVAL cvsubr(fcn,type,offset)
  126.   LVAL (*fcn)(); int type,offset;
  127. {
  128.     LVAL val;
  129.     val = newnode(type);
  130.     val->n_subr = fcn;
  131.     val->n_offset = offset;
  132.     return (val);
  133. }
  134.  
  135. /* cvfile - convert a file pointer to a stream */
  136. LVAL cvfile(fp)
  137.   FILE *fp;
  138. {
  139.     LVAL val;
  140.     val = newnode(STREAM);
  141.     setfile(val,fp);
  142.     setsavech(val,'\0');
  143.     return (val);
  144. }
  145.  
  146. /* cvfixnum - convert an integer to a fixnum node */
  147. LVAL cvfixnum(n)
  148.   FIXTYPE n;
  149. {
  150.     LVAL val;
  151.     if (n >= SFIXMIN && n <= SFIXMAX)
  152.     return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
  153.     val = newnode(FIXNUM);
  154.     val->n_fixnum = n;
  155.     return (val);
  156. }
  157.  
  158. /* cvflonum - convert a floating point number to a flonum node */
  159. LVAL cvflonum(n)
  160.   FLOTYPE n;
  161. {
  162.     LVAL val;
  163.     val = newnode(FLONUM);
  164.     val->n_flonum = n;
  165.     return (val);
  166. }
  167.  
  168. /* cvchar - convert an integer to a character node */
  169. LVAL cvchar(n)
  170.   int n;
  171. {
  172.     if (n >= CHARMIN && n <= CHARMAX)
  173.     return (&charseg->sg_nodes[n-CHARMIN]);
  174.     xlerror("character code out of range",cvfixnum((FIXTYPE)n));
  175. }
  176.  
  177. /* newustream - create a new unnamed stream */
  178. LVAL newustream()
  179. {
  180.     LVAL val;
  181.     val = newnode(USTREAM);
  182.     sethead(val,NIL);
  183.     settail(val,NIL);
  184.     return (val);
  185. }
  186.  
  187. /* newobject - allocate and initialize a new object */
  188. LVAL newobject(cls,size)
  189.   LVAL cls; int size;
  190. {
  191.     LVAL val;
  192.     val = newvector(size+1);
  193.     val->n_type = OBJECT;
  194.     setelement(val,0,cls);
  195.     return (val);
  196. }
  197.  
  198. /* newclosure - allocate and initialize a new closure */
  199. LVAL newclosure(name,type,env,fenv)
  200.   LVAL name,type,env,fenv;
  201. {
  202.     LVAL val;
  203.     val = newvector(CLOSIZE);
  204.     val->n_type = CLOSURE;
  205.     setname(val,name);
  206.     settype(val,type);
  207.     setenv(val,env);
  208.     setfenv(val,fenv);
  209.     return (val);
  210. }
  211.  
  212. /* newstruct - allocate and initialize a new structure node */
  213. LVAL newstruct(type,size)
  214.   LVAL type; int size;
  215. {
  216.     LVAL val;
  217.     val = newvector(size+1);
  218.     val->n_type = STRUCT;
  219.     setelement(val,0,type);
  220.     return (val);
  221. }
  222.  
  223. /* newvector - allocate and initialize a new vector node */
  224. LVAL newvector(size)
  225.   int size;
  226. {
  227.     LVAL vect;
  228.     int bsize;
  229.     xlsave1(vect);
  230.     vect = newnode(VECTOR);
  231.     vect->n_vsize = 0;
  232.     if (bsize = size * sizeof(LVAL)) {
  233.     if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
  234.         findmem();
  235.         if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
  236.         xlfail("insufficient vector space");
  237.     }
  238.     vect->n_vsize = size;
  239.     total += (long) bsize;
  240.     }
  241.     xlpop();
  242.     return (vect);
  243. }
  244.  
  245. #ifndef XLISP_ONLY
  246. /*** Added for internal allocated storage - L. Tierney ***/
  247. /*#include "stmem.h"  moved above JKL */
  248.  
  249. static char *IViewNewAData(n, m, size, reloc)
  250.     int n, m, reloc;
  251.     long *size;
  252. {
  253.   char *addr;
  254.   
  255.   addr = (reloc) ? (char *)StRCalloc(n, m): StCalloc(n, m);/* casts added JKL */
  256.   *size = (reloc) ? StRSize((StReallocData)addr) : ((long) m) * ((long) n);
  257.   return(addr);
  258. }
  259.  
  260. /* newadata(n, m, reloc) - convert a string to a string node */
  261. LVAL newadata(n, m, reloc)
  262.   int n, m, reloc;
  263. {
  264.     LVAL val;
  265.     long size;
  266.     
  267.     xlsave1(val);
  268.     val = newnode(ALLOCATED_DATA);
  269.     val->n_adreloc = reloc;
  270.  
  271.     if ((val->n_adaddr = IViewNewAData(n, m, &size, reloc)) == NULL) {
  272.     gc();  
  273.     if ((val->n_adaddr = IViewNewAData(n, m, &size, reloc)) == NULL)
  274.         xlfail("insufficient memory");
  275.     }
  276.     val->n_adsize = size;
  277.     total += size;
  278.  
  279.     xlpop();
  280.     return (val);
  281. }
  282.  
  283. void reallocaddata(val, n, m)
  284.     LVAL val;
  285.     int n, m;
  286. {
  287.   char *addr;
  288.   
  289.   if (! adatap(val) || ! getadreloc(val)) xlfail("not relocatable");
  290.   addr = (char *)StRRealloc((StReallocData)getadaddr(val), n, m);/* cast added JKL */
  291. /*  if (addr == NULL) xlfail("allocation failed"); no longer necessary JKL */
  292.   val->n_adaddr = addr;
  293.   total -= getadsize(val);
  294.   val->n_adsize = (int)StRSize((StReallocData)addr);/* casts added JKL */
  295.   total += getadsize(val);
  296. }
  297.  
  298. void freeadata(val)
  299.     LVAL val;
  300. {
  301.   if (! adatap(val)) xlfail("not a data object");
  302.   if (getadreloc(val)) StRFree((StReallocData)getadaddr(val));/* cast added JKL */
  303.   else StFree(getadaddr(val));
  304.   val->n_adaddr = NULL;
  305.   total -= getadsize(val);
  306.   val->n_adsize = 0;
  307. }
  308.  
  309. /*** Added for internal allocated storage - L. Tierney ***/
  310. #endif /* XLISP_ONLY */
  311.  
  312. /* newnode - allocate a new node */
  313. LOCAL LVAL newnode(type)
  314.   int type;
  315. {
  316.     LVAL nnode;
  317.  
  318.     /* get a free node */
  319.     if ((nnode = fnodes) == NIL) {
  320.     findmem();
  321.     if ((nnode = fnodes) == NIL)
  322.         xlabort("insufficient node space");
  323.     }
  324.  
  325.     /* unlink the node from the free list */
  326.     fnodes = cdr(nnode);
  327.     nfree -= 1L;
  328.  
  329.     /* initialize the new node */
  330.     nnode->n_type = type;
  331.     rplacd(nnode,NIL);
  332.  
  333.     /* return the new node */
  334.     return (nnode);
  335. }
  336.  
  337. /* stralloc - allocate memory for a string adding a byte for the terminator */
  338. LOCAL unsigned char *stralloc(size)
  339.   int size;
  340. {
  341.     unsigned char *sptr;
  342.  
  343.     /* allocate memory for the string copy */
  344.     if ((sptr = (unsigned char *)malloc(size)) == NULL) {
  345.     gc();  
  346.     if ((sptr = (unsigned char *)malloc(size)) == NULL)
  347.         xlfail("insufficient string space");
  348.     }
  349.     total += (long)size;
  350.  
  351.     /* return the new string memory */
  352.     return (sptr);
  353. }
  354.  
  355. /* findmem - find more memory by collecting then expanding */
  356. LOCAL void findmem()
  357. {
  358.     gc();
  359.     if (nfree < (long)anodes)
  360.     addseg();
  361. }
  362.  
  363. /* gc - garbage collect (only called here and in xlimage.c) */
  364. void gc()
  365. {
  366.     register LVAL **p,*ap,tmp;
  367.     char buf[STRMAX+1];
  368.     LVAL *newfp,fun;
  369.  
  370.     set_gc_cursor(TRUE); /* L. Tierney */
  371.     
  372.     /* print the start of the gc message */
  373.     if (s_gcflag && getvalue(s_gcflag)) {
  374.     sprintf(buf,"[ gc: total %ld, ",nnodes);
  375.     stdputstr(buf);
  376.     }
  377.  
  378.     /* mark the obarray, the argument list and the current environment */
  379.     if (obarray)
  380.     mark(obarray);
  381.     if (xlenv)
  382.     mark(xlenv);
  383.     if (xlfenv)
  384.     mark(xlfenv);
  385.     if (xldenv)
  386.     mark(xldenv);
  387.  
  388.     /* mark the evaluation stack */
  389.     for (p = xlstack; p < xlstktop; ++p)
  390.     if (tmp = **p)
  391.         mark(tmp);
  392.  
  393.     /* mark the argument stack */
  394.     for (ap = xlargstkbase; ap < xlsp; ++ap)
  395.     if (tmp = *ap)
  396.         mark(tmp);
  397.  
  398.     /* sweep memory collecting all unmarked nodes */
  399.     sweep();
  400.  
  401.     /* count the gc call */
  402.     ++gccalls;
  403.  
  404.     /* call the *gc-hook* if necessary */
  405.     if (s_gchook && (fun = getvalue(s_gchook))) {
  406.     newfp = xlsp;
  407.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  408.     pusharg(fun);
  409.     pusharg(cvfixnum((FIXTYPE)2));
  410.     pusharg(cvfixnum((FIXTYPE)nnodes));
  411.     pusharg(cvfixnum((FIXTYPE)nfree));
  412.     xlfp = newfp;
  413.     xlapply(2);
  414.     }
  415.  
  416.     /* print the end of the gc message */
  417.     if (s_gcflag && getvalue(s_gcflag)) {
  418.     sprintf(buf,"%ld free ]\n",nfree);
  419.     stdputstr(buf);
  420.     }
  421.     set_gc_cursor(FALSE); /* L. Tierney */
  422. }
  423.  
  424. /* mark - mark all accessible nodes */
  425. LOCAL void mark(ptr)
  426.   LVAL ptr;
  427. {
  428.     register LVAL this,prev,tmp;
  429.     int type,i,n;
  430.  
  431.     /* initialize */
  432.     prev = NIL;
  433.     this = ptr;
  434.  
  435.     /* mark this list */
  436.     for (;;) {
  437.  
  438.     /* descend as far as we can */
  439.     while (!(this->n_flags & MARK))
  440.  
  441.         /* check cons and unnamed stream nodes */
  442.         if ((type = ntype(this)) == CONS || type == USTREAM) {
  443.         if (tmp = car(this)) {
  444.             this->n_flags |= MARK|LEFT;
  445.             rplaca(this,prev);
  446.         }
  447.         else if (tmp = cdr(this)) {
  448.             this->n_flags |= MARK;
  449.             rplacd(this,prev);
  450.         }
  451.         else {                /* both sides nil */
  452.             this->n_flags |= MARK;
  453.             break;
  454.         }
  455.         prev = this;            /* step down the branch */
  456.         this = tmp;
  457.         }
  458.  
  459.         /* mark other node types */
  460.         else {
  461.         this->n_flags |= MARK;
  462.         switch (type) {
  463.         case SYMBOL:
  464.         case OBJECT:
  465.         case VECTOR:
  466.         case CLOSURE:
  467.         case COMPLEX:        /* L. Tierney */
  468.         case DISPLACED_ARRAY:/* L. Tierney */
  469.         case STRUCT:
  470.             for (i = 0, n = getsize(this); --n >= 0; ++i)
  471.             if (tmp = getelement(this,i))
  472.                 mark(tmp);
  473.             break;
  474.         }
  475.         break;
  476.         }
  477.  
  478.     /* backup to a point where we can continue descending */
  479.     for (;;)
  480.  
  481.         /* make sure there is a previous node */
  482.         if (prev) {
  483.         if (prev->n_flags & LEFT) {    /* came from left side */
  484.             prev->n_flags &= ~LEFT;
  485.             tmp = car(prev);
  486.             rplaca(prev,this);
  487.             if (this = cdr(prev)) {
  488.             rplacd(prev,tmp);            
  489.             break;
  490.             }
  491.         }
  492.         else {                /* came from right side */
  493.             tmp = cdr(prev);
  494.             rplacd(prev,this);
  495.         }
  496.         this = prev;            /* step back up the branch */
  497.         prev = tmp;
  498.         }
  499.  
  500.         /* no previous node, must be done */
  501.         else
  502.         return;
  503.     }
  504. }
  505.  
  506. /* sweep - sweep all unmarked nodes and add them to the free list */
  507. LOCAL void sweep()
  508. {
  509.     SEGMENT *seg;
  510.     LVAL p;
  511.     int n;
  512.  
  513.     /* empty the free list */
  514.     fnodes = NIL;
  515.     nfree = 0L;
  516.  
  517.     /* add all unmarked nodes */
  518.     for (seg = segs; seg; seg = seg->sg_next) {
  519.     if (seg == fixseg)     /* don't sweep the fixnum segment */
  520.         continue;
  521.     else if (seg == charseg) /* don't sweep the character segment */
  522.         continue;
  523.     p = &seg->sg_nodes[0];
  524.     for (n = seg->sg_size; --n >= 0; ++p)
  525.         if (!(p->n_flags & MARK)) {
  526.         switch (ntype(p)) {
  527.         case STRING:
  528.             if (getstring(p) != NULL) {
  529.                 total -= (long)getslength(p);
  530.                 free(getstring(p));
  531.             }
  532.             break;
  533. #ifndef XLISP_ONLY
  534.         case ALLOCATED_DATA:
  535.             if (getadaddr(p) != NULL) {
  536.                 total -= getadsize(p);          /* cast added JKL */
  537.                 if (getadreloc(p)) StRFree((StReallocData)getadaddr(p));
  538.                 else StFree(getadaddr(p));
  539.             }
  540.             break;
  541. #endif /* XLISP_ONLY */
  542.         case STREAM:
  543.             if (getfile(p))
  544.                 osclose(getfile(p));
  545.             break;
  546.         case SYMBOL:
  547.         case OBJECT:
  548.         case VECTOR:
  549.         case CLOSURE:
  550.         case COMPLEX: /* L. Tierney */
  551.         case DISPLACED_ARRAY: /*L. Tierney */
  552.         case STRUCT:
  553.             if (p->n_vsize) {
  554.                 total -= (long) ((long) p->n_vsize * sizeof(LVAL));/* (long) added - L. Tierney */
  555.                 free(p->n_vdata);
  556.             }
  557.             break;
  558.         }
  559.         p->n_type = FREE;
  560.         rplaca(p,NIL);
  561.         rplacd(p,fnodes);
  562.         fnodes = p;
  563.         nfree += 1L;
  564.         }
  565.         else
  566.         p->n_flags &= ~MARK;
  567.     }
  568. }
  569.  
  570. /* addseg - add a segment to the available memory */
  571. LOCAL int addseg()
  572. {
  573.     SEGMENT *newseg;
  574.     LVAL p;
  575.     int n;
  576.  
  577.     /* allocate the new segment */
  578.     if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
  579.     return (FALSE);
  580.  
  581.     /* add each new node to the free list */
  582.     p = &newseg->sg_nodes[0];
  583.     for (n = anodes; --n >= 0; ++p) {
  584.     rplacd(p,fnodes);
  585.     fnodes = p;
  586.     }
  587.  
  588.     /* return successfully */
  589.     return (TRUE);
  590. }
  591.  
  592. /* newsegment - create a new segment (only called here and in xlimage.c) */
  593. SEGMENT *newsegment(n)
  594.   int n;
  595. {
  596.     SEGMENT *newseg;
  597.  
  598. #ifdef MACINTOSH /* L. Tierney */
  599.     maximum_memory();
  600. #endif MACINTOSH
  601.     /* allocate the new segment */
  602.     if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
  603.     return (NULL);
  604.  
  605.     /* initialize the new segment */
  606.     newseg->sg_size = n;
  607.     newseg->sg_next = NULL;
  608.     if (segs)
  609.     lastseg->sg_next = newseg;
  610.     else
  611.     segs = newseg;
  612.     lastseg = newseg;
  613.  
  614.     /* update the statistics */
  615.     total += (long)segsize(n);
  616.     nnodes += (long)n;
  617.     nfree += (long)n;
  618.     ++nsegs;
  619.  
  620.     /* return the new segment */
  621.     return (newseg);
  622. }
  623.  
  624. /* stats - print memory statistics */
  625. LOCAL void stats()
  626. {
  627.     sprintf(buf,"Nodes:       %ld\n",nnodes); stdputstr(buf);
  628.     sprintf(buf,"Free nodes:  %ld\n",nfree);  stdputstr(buf);
  629.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  630.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  631.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  632.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  633. }
  634.  
  635. /* xgc - xlisp function to force garbage collection */
  636. LVAL xgc()
  637. {
  638.     /* make sure there aren't any arguments */
  639.     xllastarg();
  640.  
  641.     /* garbage collect */
  642.     gc();
  643.  
  644.     /* return nil */
  645.     return (NIL);
  646. }
  647.  
  648. /* xexpand - xlisp function to force memory expansion */
  649. LVAL xexpand()
  650. {
  651.     LVAL num;
  652.     int n,i;
  653.  
  654.     /* get the new number to allocate */
  655.     if (moreargs()) {
  656.     num = xlgafixnum();
  657.     n = getfixnum(num);
  658.     }
  659.     else
  660.     n = 1;
  661.     xllastarg();
  662.  
  663.     /* allocate more segments */
  664.     for (i = 0; i < n; i++)
  665.     if (!addseg())
  666.         break;
  667.  
  668.     /* return the number of segments added */
  669.     return (cvfixnum((FIXTYPE)i));
  670. }
  671.  
  672. /* xalloc - xlisp function to set the number of nodes to allocate */
  673. LVAL xalloc()
  674. {
  675.     int n,oldn;
  676.     LVAL num;
  677.  
  678.     /* get the new number to allocate */
  679.     num = xlgafixnum();
  680.     n = getfixnum(num);
  681.  
  682.     /* make sure there aren't any more arguments */
  683.     xllastarg();
  684.  
  685.     /* set the new number of nodes to allocate */
  686.     oldn = anodes;
  687.     anodes = n;
  688.  
  689.     /* return the old number */
  690.     return (cvfixnum((FIXTYPE)oldn));
  691. }
  692.  
  693. /* xmem - xlisp function to print memory statistics */
  694. LVAL xmem()
  695. {
  696.     /* allow one argument for compatiblity with common lisp */
  697.     if (moreargs()) xlgetarg();
  698.     xllastarg();
  699.  
  700.     /* print the statistics */
  701.     stats();
  702.  
  703.     /* return nil */
  704.     return (NIL);
  705. }
  706.  
  707. #ifdef SAVERESTORE
  708. /* xsave - save the memory image */
  709. LVAL xsave()
  710. {
  711.     unsigned char *name;
  712.  
  713.     /* get the file name, verbose flag and print flag */
  714.     name = getstring(xlgetfname());
  715.     xllastarg();
  716.  
  717.     /* save the memory image */
  718.     return (xlisave(name) ? true : NIL);
  719. }
  720.  
  721. /* xrestore - restore a saved memory image */
  722. LVAL xrestore()
  723. {
  724.     extern jmp_buf top_level;
  725.     unsigned char *name;
  726.  
  727.     /* get the file name, verbose flag and print flag */
  728.     name = getstring(xlgetfname());
  729.     xllastarg();
  730.  
  731.     /* restore the saved memory image */
  732.     if (!xlirestore(name))
  733.     return (NIL);
  734.  
  735.     /* return directly to the top level */
  736.     stdputstr("[ returning to the top level ]\n");
  737.     longjmp(top_level,1);
  738. }
  739. #endif /* SAVERESTORE */
  740.  
  741. /* xlminit - initialize the dynamic memory module */
  742. void xlminit()
  743. {
  744.     LVAL p;
  745.     int i;
  746.  
  747.     /* initialize our internal variables */
  748.     segs = lastseg = NULL;
  749.     nnodes = nfree = total = 0L;
  750.     nsegs = gccalls = 0;
  751.     anodes = NNODES;
  752.     fnodes = NIL;
  753.  
  754.     /* allocate the fixnum segment */
  755.     if ((fixseg = newsegment(SFIXSIZE)) == NULL)
  756.     xlfatal("insufficient memory");
  757.  
  758.     /* initialize the fixnum segment */
  759.     p = &fixseg->sg_nodes[0];
  760.     for (i = SFIXMIN; i <= SFIXMAX; ++i) {
  761.     p->n_type = FIXNUM;
  762.     p->n_fixnum = i;
  763.     ++p;
  764.     }
  765.  
  766.     /* allocate the character segment */
  767.     if ((charseg = newsegment(CHARSIZE)) == NULL)
  768.     xlfatal("insufficient memory");
  769.     
  770.     /* initialize the character segment */
  771.     p = &charseg->sg_nodes[0];
  772.     for (i = CHARMIN; i <= CHARMAX; ++i) {
  773.     p->n_type = CHAR;
  774.     p->n_chcode = i;
  775.     ++p;
  776.     }
  777.  
  778.     /* initialize structures that are marked by the collector */
  779.     obarray = xlenv = xlfenv = xldenv = NIL;
  780.     s_gcflag = s_gchook = NIL;
  781.  
  782.     /* allocate the evaluation stack */
  783.     if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
  784.     xlfatal("insufficient memory");
  785.     xlstack = xlstktop = xlstkbase + EDEPTH;
  786.  
  787.     /* allocate the argument stack */
  788.     if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
  789.     xlfatal("insufficient memory");
  790.     xlargstktop = xlargstkbase + ADEPTH;
  791.     xlfp = xlsp = xlargstkbase;
  792.     *xlsp++ = NIL;
  793. }
  794.  
  795.